Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/buttons/sprspin/sprspin.bas

BASIC Source File | 1995-06-26 | 15KB | 479 lines

' SuperSpin 1.000002
' Copyright 1995 Insert Information Technoloy
'                Bastenakenstraat 110
'                1066 JE  Amsterdam
'                The Netherlands
'                100101,[e-mail]
'
' Revision history
' 10 - 4 - 1995, version 1.000001 : Initial Release
' 26 - 4 - 1995, version 1.000002 : Sub UnloadSpin() added
'
Option Explicit
Option Base 1
Type SpinInfo
    Step As Variant
    Min As Variant
    Max As Variant
    Type As String ' Number, Date, Time
    FormatString As String
    StepChange As Integer ' allow step change with right button
    ValueList As String ' comma separated string of allowed values
End Type

Dim SpinProps() As SpinInfo
Dim iNrOfSpins As Integer
Dim SpinCntrl() As Control
Dim SetCntrl() As Control
Dim iButton As Integer
Dim sPlusMin As String ' + or -
Dim iShift As Integer ' button shift
Dim iCurrentSpin As Integer
Const LEFT_BUTTON = 1
Const RIGHT_BUTTON = 2

Private Function pfunCountChar (InputString As Variant, Char As String) As Integer
    ' This function returns the number of occurences of
    ' character Char in string InputString
    '
    Dim i As Integer
    Dim iStart As Integer
    Dim iCounter As Integer
    iStart = 1
    '
    For i = 1 To Len(InputString)
        If Mid(InputString, i, 1) = Char Then
            iCounter = iCounter + 1
        End If
    Next
    '
    pfunCountChar = iCounter
    '
End Function

Private Function pfunGetSpinNr (SpinCtl As Control) As Integer
    Dim i As Integer
    For i = 1 To iNrOfSpins
        If SpinProps(i).Type <> "" Then ' skip the free entries
            If SpinCntrl(i) = SpinCtl Then
                pfunGetSpinNr = i
                Exit Function
            End If
        End If
    Next i
    pfunGetSpinNr = 0
End Function

Private Function pfunPiece (vPieceString, vSeparator, vPieceNumber)
    ' Returns the desired piece from separated string
    If Len(vPieceString) = 0 Then
        pfunPiece = ""
        Exit Function
    End If
    Dim iCurrentPiece As Integer
    Dim iCurrentPos As Integer ' position within Piecestring
    Dim iStartPos As Integer ' Start extract
    Dim iEndPos As Integer   ' End extract
    Dim bGotcha As Integer
    iCurrentPos = 0
    iCurrentPiece = 1
    iStartPos = 1
    Do While bGotcha = False
        If iCurrentPiece = vPieceNumber Then
            bGotcha = True
            iStartPos = iCurrentPos + 1 ' without the delimiter
            If iCurrentPiece = 1 Then
                iStartPos = 1
            End If
        End If
        iCurrentPos = InStr(iCurrentPos + 1, vPieceString, vSeparator)
        If iCurrentPos = 0 Then
            iEndPos = Len(vPieceString)
            Exit Do
        End If
        If bGotcha Then
               iEndPos = iCurrentPos - 1 ' without the delimiter
        End If
        iCurrentPiece = iCurrentPiece + 1
    Loop

    If bGotcha Then
        pfunPiece = Mid(vPieceString, iStartPos, iEndPos - iStartPos + 1)
    Else
        pfunPiece = ""
    End If
End Function

Private Function pfunSpinGetListIndex (iSpinNr As Integer) As Integer
    Dim sValue As String
    sValue = SetCntrl(iSpinNr)

    If sValue = "" Then Exit Function
    Dim iPieceNr As Integer
    Dim sList As String
    sList = SpinProps(iSpinNr).ValueList

    For iPieceNr = 1 To 999
        If pfunPiece(sList, ",", iPieceNr) = sValue Then
            pfunSpinGetListIndex = iPieceNr
            Exit Function
        ElseIf pfunPiece(sList, ",", iPieceNr) = "" Then
            Exit Function
        End If
    Next iPieceNr

End Function

Private Function pfunSpinGetMax (SpinCtl As Control) As Variant
    Dim iSpinNr As Integer
    iSpinNr = pfunGetSpinNr(SpinCtl)
    If SpinProps(iSpinNr).Max = "" Then
        pfunSpinGetMax = ""
        Exit Function
    End If
    Select Case SpinProps(iSpinNr).Type
        Case "Number", "Days", "Months", "List"
            pfunSpinGetMax = Val(SpinProps(iSpinNr).Max)
        Case "Date"
            pfunSpinGetMax = CVDate(SpinProps(iSpinNr).Max)
        Case "Time"
            pfunSpinGetMax = TimeValue(SpinProps(iSpinNr).Max)
    End Select
End Function

Private Function pfunSpinGetMin (SpinCtl As Control) As Variant
    Dim iSpinNr As Integer
    iSpinNr = pfunGetSpinNr(SpinCtl)
    If SpinProps(iSpinNr).Min = "" Then
        pfunSpinGetMin = ""
        Exit Function
    End If
    Select Case SpinProps(iSpinNr).Type
        Case "Number", "Days", "Months", "List"
            pfunSpinGetMin = Val(SpinProps(iSpinNr).Min)
        Case "Date"
            pfunSpinGetMin = DateValue(SpinProps(iSpinNr).Min)
        Case "Time"
            pfunSpinGetMin = TimeValue(SpinProps(iSpinNr).Min)
    End Select

End Function

Private Function pfunSpinGetValue (SpinCtl As Control) As Variant
    Dim iSpinNr As Integer
    Dim vVal As Variant
    iSpinNr = pfunGetSpinNr(SpinCtl)
    Select Case SpinProps(iSpinNr).Type
        Case "Number"
            vVal = SetCntrl(iSpinNr)
            If SpinProps(iSpinNr).FormatString <> "" Then vVal = pfunUnFormatNumber(vVal)
            pfunSpinGetValue = vVal
        Case "Date"
            vVal = SetCntrl(iSpinNr)
            If SpinProps(iSpinNr).FormatString <> "" Then vVal = pfunUnformatDate(vVal)
            pfunSpinGetValue = DateValue(vVal)
        Case "Time"
            pfunSpinGetValue = TimeValue(SetCntrl(iSpinNr))
    End Select
End Function

Private Function pfunUnformatDate (oldVal As Variant) As Variant
    Dim sFormatString As String
    sFormatString = SpinProps(iCurrentSpin).FormatString

    ' I'd figured that it only makes sense using the weekday
    ' at the begin or the end of the FormatString separated by
    ' a space

    If Left$(sFormatString, 3) = "ddd" Then
        pfunUnformatDate = Right(oldVal, Len(oldVal) - InStr(oldVal, " ") + 1)
    ElseIf Right$(sFormatString, 3) = "ddd" Then
        pfunUnformatDate = pfunPiece(oldVal, " ", pfunCountChar(oldVal, " ") + 1)
    Else
        pfunUnformatDate = oldVal ' sigh,  dunno why I bothered in the first place
        Exit Function
    End If

End Function

Private Function pfunUnFormatNumber (oldVal As Variant)
    Dim newVal As Variant
    Dim i As Integer
    Dim sChar As String

    For i = 1 To Len(oldVal)
        sChar = Mid(oldVal, i, 1)
        If InStr("0123456789,.-+", sChar) Then newVal = newVal & sChar
    Next i

    pfunUnFormatNumber = newVal

End Function

Private Sub psubCalcNewVal (SpinCtl As Control)
    ' Calculate new value
    Dim vVal As Variant
    Dim iSpinNr As Integer
    iSpinNr = pfunGetSpinNr(SpinCtl)
    vVal = pfunSpinGetValue(SpinCtl)
    Select Case SpinProps(iSpinNr).Type
        Case "Number"
            Dim lStep As Long
            lStep = Val(SpinProps(iSpinNr).Step)
            If sPlusMin = "-" Then lStep = -lStep
            vVal = vVal + lStep
        Case "Date", "Time"
            Dim sInterval As String
            Dim iStep As Integer
            sInterval = SpinProps(iSpinNr).Step
            iStep = Val(sInterval)
            sInterval = Mid$(sInterval, InStr(sInterval, ",") + 1, Len(sInterval))
            If sPlusMin = "-" Then iStep = -iStep
            vVal = DateAdd(sInterval, iStep, vVal)
        Case "List"
            vVal = pfunSpinGetListIndex(iSpinNr)
            If sPlusMin = "+" Then
                vVal = vVal + 1
            Else
                vVal = vVal - 1
            End If
        Case "Days", "Months"
            vVal = pfunSpinGetListIndex(iSpinNr)
            If sPlusMin = "+" Then
                vVal = vVal + 1
            Else
                vVal = vVal - 1
            End If
    End Select

    If sPlusMin = "+" And (SpinProps(iSpinNr).Max <> "") Then
        Dim vMax As Variant
        vMax = pfunSpinGetMax(SpinCtl)
        If vVal > vMax Then vVal = vMax
    End If

    If sPlusMin = "-" And (SpinProps(iSpinNr).Min <> "") Then
        Dim vMin As Variant
        vMin = pfunSpinGetMin(SpinCtl)
        If vVal < vMin Then vVal = vMin
    End If

    Call SpinSetValue(iSpinNr, vVal)
End Sub

Private Sub psubSpinInitDays (iSpinNr)
    Dim i As Integer
    Dim sDay As String
    Dim sList As String
    For i = 1 To 7
        sDay = Format(CVDate(34608 + i), "dddd")
        If i > 1 Then sList = sList & ","
        sList = sList & sDay
    Next i
    SpinProps(iSpinNr).ValueList = sList
    SpinProps(iSpinNr).Min = 1
    SpinProps(iSpinNr).Max = 7
End Sub

Private Sub psubSpinInitMonths (iSpinNr As Integer)
    Dim i As Integer
    Dim sMonth As String
    Dim sList As String
    For i = 1 To 12
        sMonth = Format(CVDate("01/" & i & "/1995"), "mmmm")
        If i > 1 Then sList = sList & ","
        sList = sList & sMonth
    Next i
    SpinProps(iSpinNr).ValueList = sList
    SpinProps(iSpinNr).Min = 1
    SpinProps(iSpinNr).Max = 12
End Sub

Function SpinCurrentSpin () As Integer
    SpinCurrentSpin = iCurrentSpin
End Function

Function SpinGetStep (iSpinNr) As String
    SpinGetStep = SpinProps(iSpinNr).Step
End Function

Function SpinGetType (iSpinNr) As String
    SpinGetType = SpinProps(iSpinNr).Type
End Function

Function SpinInit (SpinCtl As Control, SetCtl As Control, sType As String) As Integer
    Dim iSpinNr As Integer
    Dim i As Integer

    ' Search for a free Spin
    iSpinNr = -1
    For i = 1 To iNrOfSpins
        If SpinProps(i).Type = "Free" Then
            iSpinNr = i
            Exit For
        End If
    Next i

    ' No free Spins : assign a new number
    If iSpinNr = -1 Then
        iNrOfSpins = iNrOfSpins + 1
        iSpinNr = iNrOfSpins
        ReDim Preserve SpinProps(iSpinNr)
        ReDim Preserve SpinCntrl(iSpinNr)
        ReDim Preserve SetCntrl(iSpinNr)
    End If

    Debug.Print "Spin Number : " & iSpinNr

    Set SpinCntrl(iSpinNr) = SpinCtl
    Set SetCntrl(iSpinNr) = SetCtl

    Select Case sType
        Case "Number", "Date", "Time", "Days", "Months", "List"
            SpinProps(iSpinNr).Type = sType
        Case Else
            SpinProps(iSpinNr).Type = "Number"
    End Select

    If sType = "Days" Then Call psubSpinInitDays(iSpinNr)
    If sType = "Months" Then Call psubSpinInitMonths(iSpinNr)

    SpinCtl.Picture = LoadPicture(App.Path & "\SPIN.BMP")
    SpinInit = iSpinNr

End Function

Sub SpinMouseDown (SpinCtl As Control, Button As Integer, Shift As Integer, X As Single, Y As Single)
    iButton = Button
    iShift = Shift
    iCurrentSpin = pfunGetSpinNr(SpinCtl)
    If Y < (SpinCtl.Height \ 2) Then
        sPlusMin = "+"
        If Button = LEFT_BUTTON Then SpinCtl.Picture = LoadPicture(App.Path & "\SPINPD.BMP")
    Else
        sPlusMin = "-"
        If Button = LEFT_BUTTON Then SpinCtl.Picture = LoadPicture(App.Path & "\SPINMD.BMP")
    End If
End Sub

Sub SpinMouseUp (SpinCtl As Control)
    ' Restore buttons
    If iButton = LEFT_BUTTON Then
        SpinCtl.Picture = LoadPicture(App.Path & "\SPIN.BMP")
        Call psubCalcNewVal(SpinCtl)
        Exit Sub
    Else
        If iShift = 0 Then
            Dim vVal As Variant ' could be anything
            If sPlusMin = "+" Then
                vVal = pfunSpinGetMax(SpinCtl)
            Else
                vVal = pfunSpinGetMin(SpinCtl)
            End If
            If vVal = "" Then Exit Sub ' none defined
            Call SpinSetValue(iCurrentSpin, vVal)
        Else ' Shift Right Button
            Dim iSpinNr As Integer
            iSpinNr = pfunGetSpinNr(SpinCtl)
            If SpinProps(iSpinNr).StepChange = True Then frmSuperSpin.Show 1
        End If
    End If
End Sub

Sub SpinSetFormat (iSpinNr As Integer, sFormatString As String)
    SpinProps(iSpinNr).FormatString = sFormatString
End Sub

Sub SpinSetList (iSpinNr As Integer, sList)
    Dim iNrOfPieces As Integer
    Dim iStartPos As Integer
    iStartPos = 1
    iNrOfPieces = 1
    Do While InStr(iStartPos, sList, ",") > 0
        iStartPos = InStr(iStartPos, sList, ",") + 1
        iNrOfPieces = iNrOfPieces + 1
    Loop
    SpinProps(iSpinNr).ValueList = sList
    SpinProps(iSpinNr).Min = 1
    SpinProps(iSpinNr).Max = iNrOfPieces
End Sub

Sub SpinSetMax (iSpinNr As Integer, vMax As Variant)
    SpinProps(iSpinNr).Max = vMax
End Sub

Sub SpinSetMin (iSpinNr As Integer, vMin As Variant)
    SpinProps(iSpinNr).Min = vMin
End Sub

Sub SpinSetStep (iSpinNr As Integer, vStep As Variant)
    Dim sType As String
    sType = SpinGetType(iSpinNr)
    Select Case sType
        Case "Number"
            SpinProps(iSpinNr).Step = vStep
        Case "Date", "Time"
            If InStr(vStep, ",") Then
                SpinProps(iSpinNr).Step = vStep
            Else
                If sType = "Date" Then
                    SpinProps(iSpinNr).Step = Val(vStep) & ",d" ' days
                Else
                    SpinProps(iSpinNr).Step = Val(vStep) & ",n" ' minutes
                End If
            End If
    End Select
End Sub

Sub SpinSetStepChange (iSpinNr, bVal As Integer)
    SpinProps(iSpinNr).StepChange = bVal
End Sub

Sub SpinSetValue (iSpinNr As Integer, vVal As Variant)
    Select Case SpinProps(iSpinNr).Type
        Case "Number"
            If SpinProps(iSpinNr).FormatString <> "" Then
                SetCntrl(iSpinNr) = Format(vVal, SpinProps(iSpinNr).FormatString)
            Else
                SetCntrl(iSpinNr) = Val(vVal)
            End If
        Case "Date"
            If SpinProps(iSpinNr).FormatString <> "" Then
                SetCntrl(iSpinNr) = Format(vVal, SpinProps(iSpinNr).FormatString)
            Else
                SetCntrl(iSpinNr) = Format(vVal, "Short Date")
            End If
        Case "Time"
            If SpinProps(iSpinNr).FormatString <> "" Then
                SetCntrl(iSpinNr) = Format(vVal, SpinProps(iSpinNr).FormatString)
            Else
                SetCntrl(iSpinNr) = Format(vVal, "hh:mm")
            End If
        Case "Days"
            SetCntrl(iSpinNr) = Format(CVDate(34608 + vVal), "dddd")
        Case "Months"
            SetCntrl(iSpinNr) = Format(CVDate("01/" & vVal & "/1995"), "mmmm")
        Case "List"
            SetCntrl(iSpinNr) = pfunPiece(SpinProps(iSpinNr).ValueList, ",", vVal)
    End Select
End Sub

Sub SpinUnload (SpinCtl As Control)
    ' Free Resources
    ' Clear Array entries
    '
    Dim iSpinNr As Integer
    iSpinNr = pfunGetSpinNr(SpinCtl)
    If iSpinNr = -1 Then Exit Sub
    Set SpinCntrl(iSpinNr) = Nothing
    Set SetCntrl(iSpinNr) = Nothing
    SpinProps(iSpinNr).Type = ""
    SpinProps(iSpinNr).Max = Null
    SpinProps(iSpinNr).Min = Null
    SpinProps(iSpinNr).Step = Null
    SpinProps(iSpinNr).ValueList = ""
    SpinProps(iSpinNr).FormatString = ""

End Sub